home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / tools.arc / TOOLS.PAS < prev   
Pascal/Delphi Source File  |  1989-03-19  |  12KB  |  456 lines

  1. {
  2. TOOLS.PAS - Screen & I/O Tools for MS and IBM Pascal
  3. copyright 1984 Ronald Florence
  4.  
  5.    WRXY - writes an lstring, with specified screen attribute, at row/col
  6.    DOXY - sets a row/col/len to a char and screen attribute
  7.    CLS - clears from 1 to 25 rows of the screen
  8.    LOCATE - places cursor at a row/col (1..25, 1..80)
  9.    CURSOR_ROW, CURSOR_COL - returns cursor location (1..25, 1..80)
  10.    INKEY - returns the next char pressed
  11.    ESCAPE - returns true if Esc is pressed
  12.    RDCHAR - waits for a char in a declared set
  13.    YES - waits for y/n; returns true if y
  14.    UPCASE - changes a string to upper case
  15.    RDSTR - inputs a string
  16.    RDINT - inputs an integer between low/high
  17.    RDREAL - inputs a decimal real
  18.       (RDSTR, RDINT, RDREAL all clear and start over if Esc is pressed during
  19.        entry. If Esc is pressed with no entry, they return false. All three 
  20.        need a writeln if used in tty-type entry. Usage: 
  21.       var i: integer;
  22.          begin
  23.                 write ('Prompt: ');
  24.             if not rdint (i, -1, 100) then return;    
  25.         writeln;                                 )
  26.    PEEK, POKE - segmented direct address procedure/functions
  27.    OK_DISP - sets video address, returns false if not 80 col text display
  28.    PUSHSCREEN - saves current screen
  29.    POPSCREEN - retrieves saved screen
  30.    PRESSED - returns next key (inc. extended ASCII, function keys, etc.)
  31.       (usage:
  32.          var key: keytype;
  33.             begin
  34.                 key:= pressed;
  35.                 if key.reg=chr(27) then do_escape
  36.                 else if key.ex=35 {alt H} then do_help
  37.                 else...)
  38.  
  39.  
  40. To use the whole package, compile it as a unit, $include the interface and
  41. put a "uses TOOLS" statement in your program heading. If you only need a few 
  42. of the functions and procedures, put the declarations back on the ones you 
  43. need and $include just the code you need in your program. Please include the 
  44. statement "copyright 1984 Ronald Florence" in any program incorporating these 
  45. procedures and functions.
  46.  
  47. Good luck. If you make any useful additions or changes, please write me:
  48.  
  49.       Ronald Florence
  50.       114 Five Mile River Road
  51.       Darien, CT 06820
  52. }
  53.  
  54.  
  55. interface;
  56.  
  57. unit tools 
  58.    (wrxy, doxy, cls, locate, cursor_row, cursor_col, 
  59.     inkey, escape, rdchar, yes, upcase, rdint, rdreal, rdstr, 
  60.     peek, poke, ok_disp, pushscreen, popscreen, pressed);
  61.  
  62. type
  63.    charset = set of char;
  64.    keytype = record
  65.                ex: byte;
  66.                reg: char
  67.              end; 
  68.  
  69. procedure wrxy (const msg: lstring; row, col: sint; att: char); 
  70. procedure doxy (ch: char; row, col: sint; att: char; len:sint);
  71. procedure cls (upper, lower: sint);
  72. procedure locate (y,x: sint);
  73. function cursor_row: sint;
  74. function cursor_col: sint;
  75. function inkey: char;
  76. function escape: boolean;
  77. function rdchar (okchars:charset): char;
  78. function yes: boolean;
  79. procedure upcase (var s: string);
  80. function rdstr (var s: string): boolean;
  81. function rdint (var i:integer; low, high: integer): boolean;
  82. function rdreal (var r:real): boolean;
  83. function peek (segment, offset: word): byte;
  84. procedure poke (segment, offset: word; argval: byte);
  85. function ok_disp: boolean;
  86. procedure pushscreen;
  87. procedure popscreen;
  88. function pressed: keytype;
  89. end;
  90.  
  91.  
  92.  
  93. implementation of tools;
  94.  
  95. type
  96.    screenchar = record
  97.                    character, attribute: char;
  98.                 end;
  99.    screentype = array [1..25, 1..80] of screenchar;
  100.    curs_pos = record
  101.                  col, row: byte;
  102.               end;   
  103.  
  104. const
  105.    blank = ' ';
  106.    norm = chr(7);
  107.  
  108. var [static]
  109.    screen: ads of screentype;
  110.    curs : ads of curs_pos;
  111.    cls_start: ads of char;
  112.    video_ads: word;
  113.    snapscreen : ^screentype;
  114.    snapcurs : curs_pos;
  115.  
  116. value
  117.    curs.s:= #0040;
  118.    curs.r:= #0050;   
  119.    screen.r:= #0;
  120.  
  121. procedure ptyuqq (len:word; loc:adsmem); extern;
  122. function dosxqq (comm, parm: word): byte; extern;
  123.  
  124. procedure wrxy;
  125. var [static]
  126.    i: sint;
  127. begin
  128.    for i := 1 to ord(msg.len) do begin
  129.       screen^[row, col].character := msg[i];
  130.       screen^[row, col].attribute := att;
  131.       col := col+1
  132.    end
  133. end;
  134.  
  135. procedure doxy;
  136. var [static]
  137.    i: sint;
  138. begin
  139.    for i := 1 to len do begin
  140.       screen^[row, col].character := ch;
  141.       screen^[row, col].attribute := att;
  142.       col := col+1
  143.    end;
  144. end;
  145.  
  146. procedure cls;
  147. type
  148.    screenline = array [1..80] of screenchar;
  149. var [static]
  150.    blankline: screenline;
  151. value
  152.    blankline:= screenline (do 80 of screenchar (blank, norm));
  153. begin
  154.    cls_start.r:= 160 * wrd(upper-1);
  155.    for var line:= upper to lower do 
  156.       [movesl (ads blankline, cls_start, 160);
  157.        cls_start.r:= cls_start.r + 160]
  158. end;
  159.  
  160. procedure locate;
  161. const
  162.    bs = chr(8);
  163. begin
  164.    curs^.col:= wrd(x);
  165.    curs^.row:= wrd(y-1);
  166.    ptyuqq (1, ads bs)
  167. end;
  168.  
  169. function cursor_row;
  170. begin
  171.    cursor_row:= ord(curs^.row + 1)
  172. end;   
  173.  
  174. function cursor_col;
  175. begin
  176.    cursor_col:= ord (curs^.col + 1)
  177. end;
  178.  
  179. function inkey;
  180. var 
  181.    b: byte;
  182. begin
  183.    repeat b:= dosxqq(6,255) until b <> 0;
  184.    inkey:= chr(b)
  185. end;
  186.  
  187. function escape;
  188. var 
  189.    b: byte;
  190. begin
  191.    b:= dosxqq(6,255);
  192.    escape:= b=27
  193. end;
  194.  
  195. function rdchar;
  196. var  
  197.    c: char;
  198. begin
  199.    repeat
  200.       c:= inkey;
  201.       if c in ['a'..'z'] then c:= chr (ord(c) - 32)
  202.    until c in okchars;
  203.    write (c);
  204.    rdchar:= c
  205. end;
  206.  
  207. function yes;
  208. var 
  209.    c: char;
  210. begin
  211.    repeat c:= inkey until c in ['y','Y','n','N'];
  212.    write (c);
  213.    yes:= c in ['y','Y']
  214. end;
  215.  
  216. procedure upcase;
  217. begin
  218.    for var c:= 1 to upper(s) do 
  219.       if s[c] in ['a'..'z'] then s[c]:= chr(ord(s[c])-32)
  220. end;
  221.  
  222. function rdstr;
  223. label
  224.    again;
  225. var 
  226.    c: char;
  227.    k: sint;
  228. begin
  229.    again:
  230.    k:= 1;
  231.    repeat 
  232.       c:= inkey; 
  233.       case c of
  234.          chr(8):  if k > 1 then begin
  235.                      write (chr(8)*blank*chr(8));
  236.                      s[k]:= blank;
  237.                      k:= k-1
  238.                   end;
  239.          chr(27): if k = 1 then begin
  240.                      rdstr:= false;
  241.                      return
  242.                   end
  243.                   else begin
  244.                      for var d:= 1 to k do s[d]:= blank;
  245.                      doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
  246.                      locate (cursor_row, cursor_col-k+1); 
  247.                      goto again
  248.                   end;                       
  249.          chr(32)..chr(126): if k <= upper(s) then 
  250.                                begin
  251.                                   write (c);
  252.                                   s[k]:= c;
  253.                                   k:= k+1 
  254.                                end
  255.                              else write (chr(7))
  256.          otherwise
  257.       end
  258.    until c=chr(13);
  259.    if k < upper(s) then for var d:= k to upper(s) do s[d]:= blank;
  260.    rdstr:= true
  261. end;
  262.  
  263. function rdint;
  264. label
  265.    again;
  266. var  
  267.    neg: boolean;
  268.    k: sint;
  269.    c: char;
  270. begin
  271.    again:
  272.    k:= 1;
  273.    i:= 0;
  274.    neg:= false;
  275.    repeat
  276.       c:= inkey;
  277.       case c of 
  278.          chr(45):  if k=1 then begin
  279.                       write (c);
  280.                       neg:= true;
  281.                       k:= k+1
  282.                    end
  283.                    else write (chr(7));
  284.          '0'..'9': begin
  285.                       write (c);
  286.                       i:= i * 10 + ord(c) - ord('0');
  287.                       k:= k+1
  288.                    end; 
  289.          chr(8) :  if k > 1 then begin
  290.                       write (chr(8)*blank*chr(8));
  291.                       if neg and (k=2) then neg:= false
  292.                       else i:= i div 10;
  293.                       k:= k-1;
  294.                    end;
  295.          chr (13): ;
  296.          chr(27):  if k = 1 then begin
  297.                       rdint:= false;
  298.                       return
  299.                    end
  300.                    else begin
  301.                       doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
  302.                       locate (cursor_row, cursor_col-k+1);
  303.                       goto again
  304.                    end;
  305.          otherwise write (chr(7))
  306.       end
  307.    until c = chr(13);
  308.    if neg then i:= - i;
  309.    if (i < low) or (i > high) then begin
  310.       write (chr(7));
  311.       doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
  312.       locate (cursor_row, cursor_col-k+1);
  313.       goto again
  314.    end
  315.    else rdint:= true
  316. end;
  317.  
  318. function rdreal;
  319. label
  320.    again;
  321. var  
  322.    left, right: integer4;
  323.    expon: real;
  324.    neg, decimal : boolean;
  325.    k: sint;
  326.    c: char;   
  327. begin
  328.    again:
  329.    k:= 1;
  330.    expon:= 1;
  331.    left:= 0;
  332.    right:= 0;
  333.    neg:= false;
  334.    decimal:= false;
  335.    repeat
  336.       c:= inkey;
  337.       case c of 
  338.          chr(45):  if k=1 then begin
  339.                       write (c);
  340.                       neg:= true;
  341.                       k:= k+1
  342.                    end
  343.                    else write (chr(7));
  344.          chr(46):  if not decimal then begin
  345.                       write (c);
  346.                       decimal:= true;
  347.                       k:= k+1;
  348.                    end
  349.                    else write (chr(7));
  350.          '0'..'9': begin
  351.                       write (c);
  352.                       if not decimal then begin
  353.                          left:= left * 10 + ord(c) - ord('0');
  354.                          k:= k+1
  355.                       end
  356.                       else begin
  357.                          right:= right * 10 + ord (c) - ord ('0');
  358.                          expon:= expon / 10;
  359.                          k:= k+1
  360.                       end
  361.                    end;
  362.          chr(8) :  if k > 1 then begin
  363.                       write (chr(8)*blank*chr(8));
  364.                       if neg and (k=2) then neg:= false
  365.                       else if not decimal then left:= left div 10
  366.                       else if decimal and (expon=1) then decimal:= false
  367.                       else begin
  368.                          right:= right div 10;
  369.                          expon:= expon * 10
  370.                       end;
  371.                       k:= k-1
  372.                    end;
  373.          chr (13): ;
  374.          chr(27):  if k = 1 then begin
  375.                       rdreal:= false;
  376.                       return
  377.                    end
  378.                    else begin
  379.                       doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
  380.                       locate (cursor_row, cursor_col-k+1);
  381.                       goto again
  382.                    end;
  383.          otherwise write (chr(7))
  384.       end;
  385.    until c = chr(13);
  386.    r:= left + expon * float4(right);
  387.    if neg then r:= - r;
  388.    rdreal:= true
  389. end;
  390.  
  391. function peek;
  392. var addr: ads of byte;
  393. begin
  394.    addr.s:= segment;
  395.    addr.r:= offset;
  396.    peek:= addr^
  397. end;
  398.  
  399. procedure poke;
  400. var addr: ads of byte;
  401. begin
  402.    addr.s:= segment;
  403.    addr.r:= offset;
  404.    addr^:= argval
  405. end;
  406.  
  407. function ok_disp;
  408. begin
  409.    case peek(#0040, #0049) of
  410.       7 : video_ads:= #B000;    {monochrome board}
  411.       2,3: video_ads:= #B800    {80 col graphics board}
  412.       otherwise
  413.          [writeln ('Program requires 80 column text display');
  414.           ok_disp:= false;
  415.           return]
  416.    end;
  417.    screen.s:= video_ads;
  418.    cls_start.s:= video_ads;
  419.    ok_disp:= true 
  420. end;
  421.  
  422. procedure pushscreen;
  423. var
  424.    oldscreen : ads of byte;
  425. begin
  426.    oldscreen.s := video_ads;
  427.    oldscreen.r := 0;
  428.    new(snapscreen);
  429.    movesl(oldscreen, ads snapscreen^, 4000);
  430.    snapcurs.row:= wrd(cursor_row);
  431.    snapcurs.col:= wrd(cursor_col)
  432. end;
  433.  
  434. procedure popscreen;
  435. var
  436.    oldscreen : ads of byte;
  437. begin
  438.    oldscreen.s := video_ads;
  439.    oldscreen.r := 0;
  440.    movesl(ads snapscreen^, oldscreen, 4000);
  441.    locate (ord(snapcurs.row), ord(snapcurs.col));
  442.    dispose(snapscreen)
  443. end;
  444.  
  445. function pressed;
  446. var
  447.    b: byte;
  448. begin
  449.    b:= dosxqq (7, 0);
  450.    pressed.reg:= chr(b);
  451.    if b <> 0 then pressed.ex:= 0
  452.    else pressed.ex:= dosxqq (7, 0)
  453. end;
  454.  
  455. end.
  456.